Visual Basic Toolbox/Visual Basic Toolbox (P.I.E.)(1996).ISO/sorting/sortcoll/sortcoll.cls

Text File | 1995-12-30 | 9.2 KB | 288 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "SortedCollection"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
'=================================================
'SortedCollection class for Visual Basic
'--------------------------------------------------------------------------------------
'12/28/95
'SortedCollection class description.
'
'I have found this to be a most useful class for writing
'database apps in VB 4.0.  The key value for the members of
'a SortedCollection class actually form a searchable index,
'unlike the unsorted key values of the generic Collection
'object.  The only catch is that you *must* specify a key for
'each member.  SortedCollection is lenient and will accept
'objects and variables of any type - the details are left to the
'programmer.
'
'Also, you must explicitly use the Item method to retrieve items
'from the SortedCollection.  The following will not work:
'
'   Dim MySortList as SortedCollection
'       .
'       .
'       .
'   SomeVariable = MySortList(1).SomeProperty   'wont work
'   SomeVariable = MySortList.Item(1).SomeProperty 'works
'
'SortedCollection also has two new helpful methods: Key(V) and
'IndexOf(V).  Key(V) will return the key name for the item at
'the Vth position (or redundantly, returns Key itself if V is a
'string).  IndexOf will return the position of the item whose
'key is V.
'
'Example:
'   MySortList.Add SomeObject, Object.Name
'   Debug.Print MySortList.IndexOf(Object.Name)  'gives new position
'
'   Debug.Print MySortList.Key(MySortList.Count) 'gives key of last
'                                               'item in collection
'
'Please note that the key is stored in ALLCAPS, and you
'cannot add keys 'german' and 'German' to the same SortedCollection.
'Note that if you use numbers as keys, 100 comes before 20 in the keys
'since the sort is alphabetic, not numeric.  If this is a problem, you
'may want to change the default behavior programmatically.
'
'How do we deal with duplicate index values?  The ErrorAction property, which
'may be set at runtime, controls the action taken when the user tries to add an
'item to the collection.  By default, it raises the error before VBA does.  If you set the
'ErrorAction to ERRACTION_INFORM, SortedCollection will post a message box
'telling the user that it will not accept the new item.  ERRACTION_IGNORE will pass
'over the attempted addition, and ERRACTION_REPLACE will replace the old
'item at that position with the new one.
'
'Of course, you can always test to see if a key is already in use by the SortedCollection.
'If IndexOf(SomeKey) = 0, then it is OK to add the new item to the SortedCollection,
'Alternatively, I have provided a simple wrapper to improve readability in the
'calling procedure: KeyInUse()
'
'I order to simplify my class, SortedCollection encapsulates two
'Collections, one which holds the actual objects in the
'collection, and one which redundantly holds the indexes as
'objects.  Since VB does not provide an easy way to retrieve the
'key value from a particular position, the synchronized key
'collection allows easy retrieval.
'
'I'm sure there are many improvements and additions which could be made
'to this crude SortedCollection class.  I would like to hear from you.
'You may use the code in this class for free, and the author makes no
'warranty as to its safety or suitability for any purpose whatsoever.
'You may send improvements, suggestions and additions to:
'
'Chris Velazquez
'[e-mail]

Option Explicit
Private prvCollection As Collection
Private prvSynchro As Collection
Private prvDuplicateIndexErrorAction As Long

Const ERR_DUPINDEX = 457
Const ERR_METHOD_NOT_APPLIC = 438

Const ERRACTION_MIN = 0
Const ERRACTION_RAISE = 0              'default (and safest!)
Const ERRACTION_INFORM = 1
Const ERRACTION_IGNORE = 2
Const ERRACTION_REPLACE = 3
Const ERRACTION_MAX = 3
'
'

Public Sub Add(V As Variant, K As Variant)     'Key not optional!!!

Dim NewKey As String
Dim NewSynchroItem As String
Dim Hi, Lo, Center As Variant

   NewSynchroItem = CStr(K)
   NewKey = UCase(NewSynchroItem)

   Select Case Count

      Case 0
         prvCollection.Add V, NewKey
         prvSynchro.Add NewSynchroItem, NewKey

      Case 1
         If Key(1) > NewKey Then
            prvCollection.Add Item:=V, Key:=NewKey, Before:=1
            prvSynchro.Add Item:=NewSynchroItem, Key:=NewKey, Before:=1

         ElseIf Key(1) < NewKey Then
            prvCollection.Add Item:=V, Key:=NewKey, After:=Count
            prvSynchro.Add Item:=NewSynchroItem, Key:=NewKey, After:=1

         Else
            HandleDuplicateIndex V, K
            Exit Sub

         End If

      Case Else
         Hi = Count
         Lo = 1

         If Key(Lo) > NewKey Then                                               'add to beginning
            prvCollection.Add Item:=V, Key:=NewKey, Before:=1
            prvSynchro.Add Item:=NewSynchroItem, Key:=NewKey, Before:=1

         ElseIf Key(Hi) < NewKey Then                                         'add to end
            prvCollection.Add Item:=V, Key:=NewKey, After:=Count
            prvSynchro.Add Item:=NewSynchroItem, Key:=NewKey, After:=Hi

         Else                                                                                  'play Hi-Lo

            Do Until Hi = Lo + 1
               Center = (Hi + Lo) \ 2               'this rounds instead of truncates
               Select Case Key(Center)

                  Case NewKey
                     HandleDuplicateIndex V, K
                     Exit Sub

                  Case Is < NewKey
                     Lo = Center

                  Case Is > NewKey
                     Hi = Center

               End Select
            Loop

            If K = Key(Hi) Or K = Key(Lo) Then
               HandleDuplicateIndex V, K
            Else
               prvCollection.Add Item:=V, Key:=NewKey, Before:=Hi
               prvSynchro.Add Item:=NewSynchroItem, Key:=NewKey, Before:=Hi
            End If
         End If

      'end of cases
   End Select
End Sub

Public Sub Remove(V)
   prvCollection.Remove V
   prvSynchro.Remove V
End Sub

Public Function Count()
   Count = prvCollection.Count
End Function

Public Function Item(V As Variant) As Variant
On Local Error Resume Next
   Item = prvCollection.Item(V)                              'works only for variables
   If Err = ERR_METHOD_NOT_APPLIC Then
      Set Item = prvCollection.Item(V)                     'works only for objects
   Else
      Err.Raise Err.Number
   End If
End Function

Private Sub Class_Initialize()
   Set prvCollection = New Collection
   Set prvSynchro = New Collection
End Sub

Public Function Key(V)
   Key = UCase(prvSynchro.Item(V))
End Function

Public Function KeyMixedCase(V)
   KeyMixedCase = prvSynchro.Item(V)
End Function

Public Sub Clear()
   Do Until Count = 0
      Remove 1
   Loop
End Sub

Public Function IndexOf(V)
Dim SearchKey As String
Dim Hi, Lo, Center

'Caution: using Key(IndexOf(blah)) may set up a recursion!
   SearchKey = UCase(V)
   If Count = 0 Then
      IndexOf = 0: Exit Function

   Else
      Lo = 1
      Hi = Count

      If SearchKey = Key(Hi) Then
         IndexOf = Hi: Exit Function
      ElseIf SearchKey = Key(Lo) Then
         IndexOf = Lo: Exit Function
      Else
         Do Until Hi <= Lo + 1
               Center = (Hi + Lo) \ 2
               Select Case SearchKey
                  Case Key(Center)
                     IndexOf = Center: Exit Function
                  Case Is < Key(Center)
                     Hi = Center
                  Case Is > Key(Center)
                     Lo = Center
               End Select
         Loop                            '(Hi <= Lo + 1)

      End If          '(SearchKey)

      If SearchKey = Key(Hi) Then
         IndexOf = Hi
      ElseIf SearchKey = Key(Lo) Then
         IndexOf = Lo
      Else
         IndexOf = 0
      End If

   End If    '(Count = 0)
End Function

Public Property Get ErrorAction() As Integer
   ErrorAction = prvDuplicateIndexErrorAction
End Property

Public Property Let ErrorAction(I As Integer)
   If I < ERRACTION_MIN Or I > ERRACTION_MAX Then
      MsgBox "SortedCollection.ErrorAction -- Invalid property value"
   Else
      prvDuplicateIndexErrorAction = I
   End If
End Property

Private Sub HandleDuplicateIndex(V As Variant, K As Variant)

   Select Case prvDuplicateIndexErrorAction

      Case ERRACTION_RAISE
         Err.Raise ERR_DUPINDEX

      Case ERRACTION_INFORM
         MsgBox "The key '" & CStr(K) & "' is already in use; cannot add item"

      Case ERRACTION_IGNORE
         'Do nothing

      Case ERRACTION_REPLACE
         Remove K
         Add V, K

   End Select

End Sub

Public Function KeyInUse(V) As Boolean
   KeyInUse = Not (IndexOf(V) = 0)
End Function